home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / GW AdaEd 1.4.2 / GWAdaDemos / NYUDemos / DATES3.ADA < prev    next >
Encoding:
Text File  |  1993-01-31  |  4.0 KB  |  157 lines  |  [TEXT/GADA]
  1. -- DEMONSTRATION PROGRAM:
  2. --   Features:
  3. --     Enumeration types, ENUM_IO (generic package), records and
  4. --     aggregates, dynamic exception handling, packages, etc.
  5.  
  6. package DATE_PKGE is
  7.    subtype DAY is integer range 1..31;
  8.    type    MONTH is (Jan, Feb, Mar, Apr, May, Jun,
  9.              Jul, Aug, Sep, Oct, Nov, Dec);
  10.    subtype YEAR is integer range 0..2000;
  11.  
  12.    type DATE is
  13.       record
  14.          D : DAY;
  15.          M : MONTH;
  16.          Y : YEAR;
  17.       end record;
  18.  
  19.    function  LEAP (Y : YEAR) return Boolean;
  20.    function  DAYS_IN_MONTH (M : MONTH; IS_LEAP : Boolean)
  21.          return DAY;
  22.    function  VALID (TODAY : DATE) return Boolean;
  23.    procedure TOMORROW (TODAY : in out DATE);
  24.    procedure READ_DATE (D : out DATE);
  25.    procedure WRITE_DATE (D : DATE);
  26.  
  27.    BAD_DATE : exception;
  28. end DATE_PKGE;
  29.  
  30. with TEXT_IO; use TEXT_IO;
  31. package body DATE_PKGE is
  32.    package MONTH_IO is new ENUMERATION_IO (MONTH);
  33.    package INT_IO is new INTEGER_IO(integer);
  34.  
  35.    function LEAP (Y : YEAR) return Boolean is
  36.    begin
  37.       return (Y mod 4 = 0) and not (Y mod 100 = 0);
  38.    end LEAP;
  39.  
  40.    function DAYS_IN_MONTH (M : MONTH; IS_LEAP : Boolean)
  41.             return DAY is
  42.    begin
  43.       case M is
  44.          when Sep | Apr | Jun | Nov => return 30;
  45.          when Feb                   =>
  46.             if IS_LEAP then 
  47.                return 29;
  48.             else
  49.                return 28;
  50.             end if;
  51.          when others                => return 31;
  52.       end case;
  53.    end DAYS_IN_MONTH;
  54.  
  55.    function VALID (TODAY : DATE) return Boolean is
  56.    begin
  57.       return TODAY.D <= DAYS_IN_MONTH (TODAY.M, LEAP (TODAY.Y));
  58.    end VALID;
  59.  
  60.    procedure TOMORROW (TODAY : in out DATE) is
  61.       LY : constant Boolean := LEAP (TODAY.Y);
  62.    begin
  63.       if not VALID (TODAY) then
  64.      new_line;
  65.          put_line("There can be no tomorrow when there is no today.");
  66.          raise BAD_DATE;
  67.       elsif TODAY.D < DAYS_IN_MONTH (TODAY.M, LY) then
  68.          TODAY.D := TODAY.D + 1;           -- not last day of month
  69.       elsif TODAY.M < Dec then
  70.          TODAY.D := 1;                     -- last day of month
  71.          TODAY.M := MONTH'SUCC (TODAY.M);  -- but not last month of year
  72.       elsif TODAY.Y < YEAR'LAST then
  73.          TODAY := (1, Jan, TODAY.Y + 1);   -- last day of year
  74.       else
  75.          new_line;
  76.          put_line(" Beyond the end of time...");
  77.                                  -- run out of years
  78.          raise BAD_DATE;
  79.       end if;
  80.    end TOMORROW;
  81.  
  82.    procedure READ_DATE (D : out DATE) is
  83.       use MONTH_IO, INT_IO;
  84.       type DATE_COMPONENTS is ('D', 'M', 'Y');
  85.    begin
  86.       for I in DATE_COMPONENTS 
  87.       loop
  88.      loop
  89.             declare
  90.         begin
  91.                case I is
  92.                   when 'D' =>
  93.              put_line("Day:   ");
  94.              get (D.D);
  95.                   when 'M' =>
  96.              put_line("Month: ");
  97.              get (D.M);
  98.                   when 'Y' =>
  99.              put_line("Year:  ");
  100.              get (D.Y);
  101.                end case;
  102.            exit;
  103.         exception
  104.            when DATA_ERROR | CONSTRAINT_ERROR =>
  105.                   case I is
  106.                      when 'D' =>
  107.             put_line("Please enter integer from 1 to 31.");
  108.                      when 'M' =>
  109.             put_line(
  110.              "Please enter three-letter abbreviation " &
  111.                  "(i.e. Jan).");
  112.                      when 'Y' =>
  113.             put_line(
  114.               "Please enter integer from 0 to 2000.");
  115.           end case;
  116.         end;
  117.      end loop;
  118.       end loop;
  119.    end READ_DATE;
  120.  
  121.    procedure WRITE_DATE (D : DATE) is
  122.       use MONTH_IO, INT_IO;
  123.    begin
  124.       put (D.M);
  125.       put (" ");
  126.       put (D.D);
  127.       put (", ");
  128.       put (D.Y);
  129.    end WRITE_DATE;
  130. end DATE_PKGE;
  131.  
  132. with TEXT_IO, DATE_PKGE; use TEXT_IO, DATE_PKGE;
  133. procedure dates3 is
  134.    today : DATE;
  135. begin
  136.    loop
  137.       declare
  138.       begin
  139.      READ_DATE (today);
  140.      new_line;
  141.      put("Today is... ");
  142.      WRITE_DATE (today);
  143.      TOMORROW (today);
  144.      put(" and tomorrow is... ");
  145.      WRITE_DATE (today);
  146.      new_line(2);
  147.       exception
  148.          when BAD_DATE =>
  149.             new_line;
  150.      when END_ERROR =>
  151.         new_line;
  152.         put_line("Have a nice day!");
  153.             exit;
  154.       end;
  155.    end loop;
  156. end dates3;
  157.